PC Plus SuperCD (UK) 1995 March/PC Plus Super CD (Issue 101) (March 1995).iso/pcplus/superdsk/visbasic/snapshot.frm

Visual Basic Form | 1994-11-29 | 18.6 KB | 588 lines

VERSION 2.00
Begin Form Main
   BackColor       =   &H00000000&
   Caption         =   "SnapShot 1.1"
   ClientHeight    =   5910
   ClientLeft      =   375
   ClientTop       =   1815
   ClientWidth     =   7395
   ClipControls    =   0   'False
   FillColor       =   &H00C00000&
   FillStyle       =   0  'Solid
   Height          =   6600
   HelpContextID   =   3
   Icon            =   0
   Left            =   315
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   5910
   ScaleWidth      =   7395
   Top             =   1185
   Width           =   7515
   Begin DriveListBox Drive1
      BackColor       =   &H00FFFFFF&
      Height          =   315
      HelpContextID   =   3
      Left            =   240
      TabIndex        =   3
      Top             =   840
      Width           =   2295
   End
   Begin Timer Timer2
      Interval        =   100
      Left            =   3960
      Top             =   3240
   End
   Begin Timer Timer1
      Interval        =   100
      Left            =   3180
      Top             =   3240
   End
   Begin CheckBox Check1
      Alignment       =   1  'Right Justify
      BackColor       =   &H00800000&
      Caption         =   "Recycle Slides:"
      ForeColor       =   &H0000FFFF&
      Height          =   315
      HelpContextID   =   3
      Left            =   3060
      TabIndex        =   6
      Top             =   4980
      Width           =   1695
   End
   Begin TextBox Text1
      Alignment       =   2  'Center
      BackColor       =   &H00800000&
      BorderStyle     =   0  'None
      ForeColor       =   &H0000FFFF&
      Height          =   255
      HelpContextID   =   3
      Left            =   4500
      TabIndex        =   5
      Text            =   "5"
      Top             =   4620
      Width           =   255
   End
   Begin FileListBox File1
      BackColor       =   &H00FFFF00&
      Height          =   4515
      HelpContextID   =   4
      Left            =   5220
      MultiSelect     =   2  'Extended
      Pattern         =   "*.bmp;*.wmf;*.ico;*.rle"
      TabIndex        =   0
      Top             =   840
      Width           =   1935
   End
   Begin DirListBox Dir1
      BackColor       =   &H00FFFF00&
      ForeColor       =   &H00000000&
      Height          =   3405
      HelpContextID   =   3
      Left            =   240
      TabIndex        =   1
      Top             =   1560
      Width           =   2295
   End
   Begin Image Image1
      BorderStyle     =   1  'Fixed Single
      Height          =   2055
      Left            =   2820
      Stretch         =   -1  'True
      Top             =   540
      Width           =   2115
   End
   Begin Line Line3
      BorderColor     =   &H0000FFFF&
      X1              =   1500
      X2              =   1500
      Y1              =   4980
      Y2              =   5400
   End
   Begin Line Line2
      BorderColor     =   &H0000FFFF&
      X1              =   180
      X2              =   2580
      Y1              =   4980
      Y2              =   4980
   End
   Begin Line Line1
      BorderColor     =   &H0000FFFF&
      X1              =   2760
      X2              =   4980
      Y1              =   4380
      Y2              =   4380
   End
   Begin Label Tym
      Alignment       =   2  'Center
      BackColor       =   &H00FFFFFF&
      BackStyle       =   0  'Transparent
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   9.75
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H00FFFFFF&
      Height          =   255
      Left            =   1620
      TabIndex        =   4
      Top             =   5100
      Width           =   855
   End
   Begin Label Datum
      Alignment       =   2  'Center
      BackColor       =   &H00FFFFFF&
      BackStyle       =   0  'Transparent
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   9.75
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H00FFFFFF&
      Height          =   255
      Left            =   300
      TabIndex        =   10
      Top             =   5100
      Width           =   1095
   End
   Begin Line Line11
      BorderColor     =   &H0000FFFF&
      X1              =   180
      X2              =   2580
      Y1              =   1200
      Y2              =   1200
   End
   Begin Label DriveLabel
      BackStyle       =   0  'Transparent
      Caption         =   " Drive"
      ForeColor       =   &H00FFFFFF&
      Height          =   630
      Left            =   240
      TabIndex        =   2
      Top             =   540
      Width           =   2295
   End
   Begin Label FileLabel
      BackStyle       =   0  'Transparent
      Caption         =   " File(s)"
      ForeColor       =   &H00FFFFFF&
      Height          =   255
      Left            =   5220
      TabIndex        =   13
      Top             =   540
      Width           =   1875
   End
   Begin Label PathLabel
      BackStyle       =   0  'Transparent
      Caption         =   " Path"
      ForeColor       =   &H00FFFFFF&
      Height          =   255
      Left            =   270
      TabIndex        =   12
      Top             =   1260
      Width           =   2280
   End
   Begin Label InfoLabel
      Alignment       =   2  'Center
      BackColor       =   &H00C0C0C0&
      ForeColor       =   &H00FF0000&
      Height          =   1635
      Left            =   2820
      TabIndex        =   11
      Top             =   2700
      Width           =   2115
   End
   Begin Label Message
      Alignment       =   2  'Center
      BackColor       =   &H00000000&
      ForeColor       =   &H0000FFFF&
      Height          =   195
      Left            =   60
      TabIndex        =   7
      Top             =   60
      Width           =   7275
   End
   Begin Label MessageLabel
      AutoSize        =   -1  'True
      BackColor       =   &H00000000&
      ForeColor       =   &H0000FF00&
      Height          =   255
      Left            =   60
      TabIndex        =   8
      Top             =   5640
      Width           =   7275
   End
   Begin Line Line4
      BorderColor     =   &H0000FFFF&
      X1              =   2760
      X2              =   4995
      Y1              =   2640
      Y2              =   2640
   End
   Begin Shape Shape3
      BackColor       =   &H00808080&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H0000FFFF&
      FillColor       =   &H00FF0000&
      FillStyle       =   0  'Solid
      Height          =   4935
      Left            =   180
      Top             =   480
      Width           =   2415
   End
   Begin Label SlideLabel
      Alignment       =   2  'Center
      BackColor       =   &H00808080&
      BackStyle       =   0  'Transparent
      Caption         =   "Slide Interval:"
      ForeColor       =   &H0000FFFF&
      Height          =   255
      Left            =   3060
      TabIndex        =   9
      Top             =   4620
      Width           =   1335
   End
   Begin Shape Shape2
      BackColor       =   &H00800000&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00C0C0C0&
      Height          =   495
      Left            =   2820
      Top             =   4440
      Width           =   2115
   End
   Begin Shape Shape1
      BorderColor     =   &H0000FFFF&
      Height          =   4935
      Left            =   2760
      Top             =   480
      Width           =   2235
   End
   Begin Shape Shape8
      BackColor       =   &H00800000&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00C0C0C0&
      Height          =   435
      Left            =   2820
      Top             =   4920
      Width           =   2115
   End
   Begin Shape Shape4
      BackColor       =   &H00FF0000&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H0000FFFF&
      Height          =   4935
      Left            =   5160
      Top             =   480
      Width           =   2055
   End
   Begin Shape Shape5
      BackColor       =   &H00000000&
      BackStyle       =   1  'Opaque
      Height          =   2055
      Left            =   2820
      Top             =   540
      Width           =   2115
   End
   Begin Shape Shape9
      BackColor       =   &H0000FFFF&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H0000FFFF&
      FillColor       =   &H00000080&
      FillStyle       =   0  'Solid
      Height          =   5295
      Left            =   0
      Top             =   300
      Width           =   7395
   End
   Begin Menu exit
      Caption         =   "  &Exit"
   End
   Begin Menu space1
      Caption         =   "                                        "
   End
   Begin Menu View
      Caption         =   "&View"
   End
   Begin Menu space2
      Caption         =   "                         "
   End
   Begin Menu Help
      Caption         =   "&Help = F1"
   End
Dim Shared cfg As String * 50, Pad As String * 47, FName$
Dim Shared Messag$, DriveName As String * 2
Sub Check1_Click ()
cycle = check1.Value
End Sub
Sub Check1_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
Message.Caption = "Click to make the slide show repeat itself after the given slide delay"
End Sub
Sub Datum_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
Message.Caption = "Yep, it's " + Format$(Now, "dddd, mmmm d, yyyy")
End Sub
Sub Dir1_Change ()
'Unload picture when path changes
File1.Path = Dir1.Path
image1.Picture = LoadPicture()
InfoLabel.Caption = ""
End Sub
Sub Dir1_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
Message.Caption = "Choose a new path for your files by double-clicking the folder"
End Sub
Sub Drive1_Change ()
On Error GoTo nodrive
' When Drive changes, set Dir path
Dir1.Path = drive1.Drive
DriveName = drive1.Drive
image1.Picture = LoadPicture()
InfoLabel.Caption = ""
Exit Sub
'Error-Handler if drive not available
nodrive:
Beep: MsgBox "Cannot read from drive " + UCase$(drive1.Drive) + " ", 16, "Error"
drive1.Drive = DriveName: Exit Sub
Resume Next
End Sub
Sub DriveLabel_Click ()
drive1.SetFocus
End Sub
Sub DriveLabel_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
Message.Caption = "Choose a new drive to access by clicking on the drive icon"
End Sub
Sub exit_Click ()
'Save the defaults (delay,cycle,path)
'They are saved in the directory user started SnapShot
Dim DefSave As String * 2, DefSave2 As String * 2
DefSave = LTrim$(Str$(delay)): If Len(DefSave) = 1 Then DefSave = "0" + DefSave
DefSave2 = LTrim$(Str$(cycle))
FNum = FreeFile
Open app.Path + "\snapshot.cfg" For Random As FNum Len = Len(cfg)
cfg = DefSave + DefSave2 + Dir1.Path
Put FNum, 1, cfg
Close FNum
'Program ends here
'If you exit by means of the control box of the form
'the defaults are not saved!
End Sub
Sub file1_click ()
On Error GoTo fault
Timer1.Enabled = True
PictureName$ = Dir1.Path
If Right$(PictureName$, 1) <> "\" Then PictureName$ = PictureName$ + "\"
PictureName$ = PictureName$ + File1.FileName
FName$ = File1.FileName
InfoLabel.Caption = "FileName:" + Chr$(13) + UCase$(FName$) + Chr$(13) + Chr$(13) + "FileSize: " + Chr$(13) + Str$(FileLen(PictureName$)) + " bytes" + Chr$(13) + Chr$(13) + "Last modified on:" + Chr$(13) + FileDateTime(PictureName$)
image1.Visible = False
image1.Height = 2055
image1.Width = 2115
image1.Picture = LoadPicture(PictureName$)
image1.Visible = True
Exit Sub
'Error Handler
fault:
Beep: MsgBox File1.FileName + " is" + Chr$(10) + "an " + Error$(Err), 16, "Error"
image1.Picture = LoadPicture()
Resume Next
End Sub
Sub File1_DblClick ()
slide = 0: Full.Show
End Sub
Sub File1_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
Pad = Dir1.Path
Message.Caption = "Select one or more pictures from the File(s) list and activate 'View'"
End Sub
Sub File1_PathChange ()
PictureName$ = Dir1.Path
End Sub
Sub FileLabel_Click ()
'If files have been modified or added,
'updating of the file(s) list
File1.Path = Dir1.Path
File1.Refresh
image1.Picture = LoadPicture()
InfoLabel.Caption = ""
File1.SetFocus
End Sub
Sub FileLabel_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
Pad = Dir1.Path
Message.Caption = "Click here to refresh and/or update the files list"
End Sub
Sub form_load ()
On Error GoTo Faults
Randomize Timer
top = (screen.Height - Height) / 2
left = (screen.Width - Width) / 2
Timer1.Interval = 65000
app.HelpFile = "snapshot.hlp"
MessageLabel.ForeColor = QBColor(Rnd * 5 + 10)
DriveName = drive1.Drive
'The data for scrolling the message bar
Messag$ = String$(86, 32)
Messag$ = Messag$ + "SnapShot - version 1.1 - Pcs 1994 -                         "
Messag$ = Messag$ + "This is a free program to use and to copy as long as you mention "
Messag$ = Messag$ + "the original author - which is PcS - if you change any of the supplied files !"
Messag$ = Messag$ + "             The thing which would please me the most is for you to send me a postcard "
Messag$ = Messag$ + "with your greetings to:      PcS - Molenstraat 106 - 2940 Hoevenen - Belgium ....."
Messag$ = Messag$ + "                  Thank you for your trouble and enjoy .......                             "
delay = 5: cycle = 0
'Read the configuration file if any
'and fill in the variables
FNum = FreeFile
Open app.Path + "\snapshot.cfg" For Random As FNum Len = Len(cfg)
If LOF(FNum) / Len(cfg) = 1 Then
Rem cfg = a$ + b$ + Pad
Get FNum, 1, cfg
delay = Val(Left$(cfg, 2))
cycle = Val(Mid$(cfg, 3, 1))
Pad = RTrim$(Mid$(cfg, 4))
Dir1.Path = Pad
drive1.Drive = Dir1.Path
End If
Close FNum
Text1.Text = LTrim$(Str$(delay))
Text1.SelLength = Len(Text1.Text)
Text1.MaxLength = 2
check1.Value = cycle
Exit Sub
'Error-Handler if path not found
Faults:
Resume nopad
nopad:
drive1.Drive = "c:"
Dir1.Path = "c:\"
End Sub
Sub Form_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
Message.Caption = ""
End Sub
Sub Form_Resize ()
'Set default form height and width if user resizes window
'Not if minimized
If windowstate <> 0 Then Exit Sub
Width = 7515
Height = 6525
End Sub
Sub Help_Click ()
File1.HelpContextID = 1
SendKeys "{F1}", True
File1.HelpContextID = 4
End Sub
Sub Image1_Click ()
On Error GoTo nocopy
'If valid picture loaded, copy picture to the ClipBoard
If FName$ <> "" Then
    If Right$(PictureName$, 4) <> ".ico" Then
        Clipboard.SetData LoadPicture(PictureName$), 8
        MsgBox UCase$(PictureName$) + " saved to ClipBoard", 64, "Copy Successful"
    Else
        MsgBox "Sorry, icons (ICO) cannot be copied to the ClipBoard", 16, "Error"
    End If
End If
nocopy2:
Exit Sub
'Error Handler
nocopy:
MsgBox Error$(Err), 16, "Error"
Resume nocopy2
End Sub
Sub Image1_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo nopb
Static imedit As Integer
If Button = 2 Then
    If FName$ <> "" Then
        If Right$(FName$, 3) <> "bmp" Then
            Beep: MsgBox "Sorry, PAINTBRUSH can only load BMP files", 16, "Error"
            Exit Sub
        End If
        imedit = Shell("c:\windows\pbrush" + " " + PictureName$, 3)
    Else
        imedit = Shell("c:\windows\pbrush", 3)
    End If
End If
Exit Sub
nopb:
Beep: MsgBox "Program PBRUSH.EXE was not" + Chr$(10) + "found in directory C:\WINDOWS", 16, "Error": Resume Next
End Sub
Sub Image1_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
Message.Caption = "Left-Click picture to copy to CLIPBOARD, right-click to load into PAINTBRUSH"
End Sub
Sub InfoLabel_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
Message.Caption = "Here's some useful information about the selected file (if one is selected !)"
End Sub
Sub Message_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
Message.Caption = "If you haven't guessed it already, this is the message bar"
End Sub
Sub MessageLabel_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
Message.Caption = "What'd you know, a scrolling advertizing bar ! Please read carefully !"
End Sub
Sub PathLabel_Click ()
Dir1.SetFocus
End Sub
Sub PathLabel_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
Message.Caption = "Choose a new path for your files by double-clicking the folder"
End Sub
Sub SlideLabel_Click ()
Text1.SetFocus
End Sub
Sub SlideLabel_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
Message.Caption = "Choose a delay between slides from 1 up to 60 seconds"
End Sub
Sub Text1_GotFocus ()
'Text1 is the input field for the slide show interval
Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)
End Sub
Sub Text1_KeyPress (keyascii As Integer)
If keyascii = 13 Then File1.SetFocus
End Sub
Sub Text1_LostFocus ()
delay = Val(Text1.Text): If delay < 1 Or delay > 60 Then delay = 5: Text1.Text = "5"
End Sub
Sub Timer1_Timer ()
Tym.Caption = Left$(Time$, 5)
Datum.Caption = Format$(Now, "mm-dd-yy")
End Sub
Sub Timer2_Timer ()
Randomize Timer
Static loop1, loop2
loop1 = Len(Messag$)
loop2 = loop2 + 1
If loop2 = loop1 - 86 Then
loop2 = 1
MessageLabel.ForeColor = QBColor(Rnd * 5 + 10)
End If
MessageLabel.Caption = Mid$(Messag$, loop2, 86)
End Sub
Sub Tym_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
Message.Caption = "Keep an eye on the time while you browse your files"
End Sub
Sub view_click ()
Dim loop1 As Integer, flag As Integer
'Flag indicates if only or several pictures are selected
flag = 0
File1.SetFocus
If File1.ListCount = 0 Then Exit Sub
For loop1 = 0 To File1.ListCount - 1
    If File1.Selected(loop1) = True Then
        flag = flag + 1
        If flag > 1 Then Exit For
    End If
If flag = 0 Then Beep: Exit Sub
If flag = 1 Then
    If FName$ <> "" Then
        Timer1.Enabled = False
        timer2.Enabled = False
        slide = 0
        Full.Show
        Exit Sub
    End If
End If
Timer1.Enabled = False
timer2.Enabled = False
slide = 1
Full.Timer1.Enabled = True
Full.Show
End Sub